Option Compare Database
Option Explicit
'************************************************************************************************
'*                           EXPORT TO EXCEL CLASS MODULE                                       *
'* Author: Danny King                                                                           *
'* Versions Supported: Access 2000 and above                                                    *
'* Licence: Free to use and distribute, proving all comments are left as is, and credit is given*
'* to the author where applicable                                                               *
'* Class Version: 1.1                                                                           *
'* CommonDialog Method taken from Access Developer's Handbook                                   *
'************************************************************************************************
'* DESCRIPTION                                                                                  *
'* Class module is used to take any table (in either the current database or any other database *
'* that is linked through DAO), and export it to either an existing spreadsheet or into a new   *
'* spreadsheet.                                                                                 *
'*                                                                                              *
'* Requirements:    Reference to both DAO and Excel Object in the database                      *
'* Outputs:         Excel Spreadsheet of table or SQL Recordset's data                          *
'************************************************************************************************
'* Pointers before calling:                                                                     *
'*                                                                                              *
'* Either show or hide the excel application by setting ShowExcel Value                         *
'* Include or exclude exported object's fieldnames by setting IncludeFields Value               *
'* Leave Excel open at the end or close it by setting CloseWhenDone Value                       *
'* Save spreadsheet when finished or save as original by setting SaveWhenDone Value             *
'* Select Filename to be used by setting FileName Value, if not supplied then new workbook      *
'* Select Sheetname on existing or new workbook by setting SheetName Value, defaults to "Sheet1"*
'* Select Cell to start populating from by setting CellAddress Value, defaults to "A1"          *
'* Select RangeAddress to populate from by setting RangeAddress Value, no default               *
'* Select table to export by setting TableName Value, no default                                *
'* Or set an SQL query to be exported by setting SQL Value, no default                          *
'* Choose a different filename to save as by setting SaveAs Value, no default                   *
'* Finally choose a different database to export by setting DBName, default CurrentDb           *
'************************************************************************************************
'* To export just run function export either before or after setting values.  The table name or *
'* SQL must be set before calling this function.                                                *
'************************************************************************************************

Private Type tagOPENFILENAME
     lStructSize As Long
     hWndOwner As Long
     hInstance As Long
     strFilter As String
     strCustomFilter As String
     nMaxCustFilter As Long
     NFilterIndex As Long
     strFile As String
     nMaxFile As Long
     strFileTitle As String
     nMaxFileTitle As Long
     strInitialDir As String
     strTitle As String
     Flags As Long
     nFileOffset As Integer
     nFileExtension As Integer
     strDefExt As String
     lCustData As Long
     lpfnHook As Long
     lpTemplateName As String
End Type
Private Declare Function adh_apiGetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (ofn As tagOPENFILENAME) As Boolean
Private Declare Function adh_apiGetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (ofn As tagOPENFILENAME) As Boolean
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Private Const adhOFN_READONLY = &H1
Private Const adhOFN_OVERWRITEPROMPT = &H2
Private Const adhOFN_HIDEREADONLY = &H4
Private Const adhOFN_NOCHANGEDIR = &H8
Private Const adhOFN_SHOWHELP = &H10
Private Const adhOFN_NOVALIDATE = &H100
Private Const adhOFN_ALLOWMULTISELECT = &H200
Private Const adhOFN_EXTENSIONDIFFERENT = &H400
Private Const adhOFN_PATHMUSTEXIST = &H800
Private Const adhOFN_FILEMUSTEXIST = &H1000
Private Const adhOFN_CREATEPROMPT = &H2000
Private Const adhOFN_SHAREAWARE = &H4000
Private Const adhOFN_NOREADONLYRETURN = &H8000
Private Const adhOFN_NOTESTFILECREATE = &H10000
Private Const adhOFN_NONETWORKBUTTON = &H20000
Private Const adhOFN_NOLONGNAMES = &H40000
Private Const adhOFN_EXPLORER = &H80000
Private Const adhOFN_NODEREFERENCELINKS = &H100000
Private Const adhOFN_LONGNAMES = &H200000

Private Type Props
  blnShowExcel As Boolean
  blnIncludeFields As Boolean
  blnCloseWhenFinished As Boolean
  strFileName As String
  blnFileGiven As Boolean
  strShortFName As String
  blnSaveWhenDone As Boolean
  strSheetName As String
  blnSheetGiven As Boolean
  strCellAddress As String
  blnCellGiven As Boolean
  strRangeAddress As String
  blnRangeGiven As Boolean
  strTableName As String
  blnTableGiven As Boolean
  strSQLQuery As String
  blnSQLGiven As Boolean
  strSaveFileName As String
  blnSaveFileName As Boolean
  strDBName As String
  blnDBGiven As Boolean
End Type

Private Const Message As String = "Uninitialized Property"
Private Const strTitle As String = "clsExport"
Public TableNames As New Collection
Private Properties As Props, Db As DAO.Database, Rc As DAO.Recordset, Doc As DAO.Document
Private obXL As New Excel.Application, FileOpened As Boolean, strCurrDir As String

Private Sub Class_Initialize()
  'open the instance of excel
  obXL.Visible = False
  'Write the default values out if different from the intital variable value
  Properties.blnCloseWhenFinished = True
  Properties.blnSaveWhenDone = True
  strCurrDir = "C:\"
  GetTableNames
End Sub

Private Sub Class_Terminate()
  'release the instance of excel,
  If Properties.blnCloseWhenFinished = True Then
    obXL.Quit
  End If
  Set obXL = Nothing
End Sub

Private Sub GetTableNames(Optional DBName As String)
  'When first called it obtains the tablenames held within the database
  Dim Doc As DAO.Document
  'clear the original collection
  Dim i As Integer
  If (TableNames.Count > 0) Then
    For i = 1 To TableNames.Count
      TableNames.Remove 1
    Next i
  End If
  If DBName = "" Then
    Set Db = CurrentDb
  Else
    Set Db = DAO.OpenDatabase(DBName)
  End If
  For Each Doc In Db.Containers!Tables.Documents
    If Left(Doc.Name, 1) <> "~" And Left(Doc.Name, 4) <> "Msys" Then TableNames.Add Doc.Name
  Next Doc
  Set Db = Nothing
End Sub
Property Let SheetName(Name As String)
  'cannot validate the sheet name until export is determined
  Properties.blnSheetGiven = (Name <> "")
  Properties.strSheetName = Name
End Property
Property Get SheetName() As String
  SheetName = Nz(Properties.strSheetName, Message)
End Property
Property Let CellAddress(Name As String)
  'check to make sure that this is only one cell and it is within the normal excel range
  Dim strLetters As String
  Dim lngNumbers As Long
  Dim i As Integer
  Dim blnRefError As Boolean
  If Name = "" Then
    Properties.strCellAddress = ""
    Properties.blnCellGiven = False
    Exit Property
  End If
  If InStr(Name, ":") > 0 Then
    blnRefError = True
    GoTo QuickExit
  End If
  'strip the letters and numbers into the require variables
  For i = 1 To Len(Name)
    If IsNumeric(Mid(Name, i, 1)) = True Then
      strLetters = UCase(Left(Name, i - 1))
      lngNumbers = CLng(Right(Name, Len(Name) - i + 1))
      Exit For
    End If
  Next i
  If (lngNumbers < 1) Or (lngNumbers > 65536) Then blnRefError = True
  If Len(strLetters) > 2 Then blnRefError = False
  If Mid(strLetters, 1, 1) Like "[V-Z]" Then blnRefError = True
  If (Len(strLetters) = 2) And (Mid(strLetters, 1, 1) = "I") And (Mid(strLetters, 2, 1) Like "[W-Z]") Then blnRefError = True
  
QuickExit:
  If blnRefError = True Then
    MsgBox "Please send a valid cell reference", vbCritical, strTitle
    Properties.strCellAddress = ""
    Properties.blnCellGiven = False
  Else
    Properties.strCellAddress = Name
    Properties.blnCellGiven = True
  End If
End Property
Property Get CellAddress() As String
  CellAddress = Nz(Properties.strCellAddress, Message)
End Property
Property Let RangeAddress(Name As String)
  'cannot physically check the range address without opening the file itself, so take the user's
  'word for it check before exporting
  Properties.blnRangeGiven = (Name <> "")
  Properties.strRangeAddress = Name
End Property
Property Get RangeAddress() As String
  RangeAddress = Nz(Properties.strRangeAddress, Message)
End Property
Property Let Filename(Name As String)
  'check for existance of the filename being supplied
  Properties.strFileName = Name
  Properties.blnFileGiven = (Name <> "")
End Property
Property Get Filename() As String
  Filename = Nz(Properties.strFileName, Message)
End Property
Property Let IncludeFields(Value As Boolean)
  Properties.blnIncludeFields = Value
End Property
Property Get IncludeFields() As Boolean
  IncludeFields = Properties.blnIncludeFields
End Property
Property Let ShowExcel(Value As Boolean)
  Properties.blnShowExcel = Value
  obXL.Visible = Value
  If Value Then obXL.WindowState = xlMinimized
End Property
Property Get ShowExcel() As Boolean
  ShowExcel = Properties.blnShowExcel
End Property
Property Let CloseWhenDone(Value As Boolean)
  Properties.blnCloseWhenFinished = Value
End Property
Property Get CloseWhenDone() As Boolean
  CloseWhenDone = Properties.blnCloseWhenFinished
End Property
Property Let TableName(Name As String)
  'check for existance of this table name before assigning
  Dim TableFound As Boolean
  With Properties
    If Name = "" Then
      .strTableName = ""
      .blnTableGiven = False
      Exit Property
    End If
    'if an external database has been given then open this database and check for the table
    If .blnDBGiven = True Then
      Set Db = DAO.OpenDatabase(.strDBName)
    Else
      Set Db = CurrentDb
    End If
    For Each Doc In Db.Containers!Tables.Documents
      If Doc.Name = Name Then TableFound = True: Exit For
    Next Doc
    If TableFound Then
      .strTableName = Name
      .blnTableGiven = True
    Else
      MsgBox "Please send a table name that resides in the given database.", vbCritical + vbOKOnly, strTitle
    End If
    If .blnDBGiven = True Then Db.Close
    Set Db = Nothing
  End With
End Property
Property Get TableName() As String
  TableName = Nz(Properties.strTableName, Message)
End Property
Property Let DBName(Name As String)
  'attempt to connect to the requested database through DAO if failure then inform
  If Name = "" Then
    Properties.strDBName = ""
    Properties.blnDBGiven = False
    Exit Property
  End If
  On Error GoTo NoDBExist
  If Name <> CurrentDb.Name Then
    Set Db = DAO.OpenDatabase(Name)
    Db.Close
    Properties.strDBName = Name
    Properties.blnDBGiven = True
    GetTableNames Name
  Else
    MsgBox "This value cannot be set as the current database.", vbCritical, strTitle
  End If
  On Error GoTo 0
  Exit Property

NoDBExist:
  On Error GoTo 0
  MsgBox "Please supply a valid location to a database.", vbCritical + vbOKOnly, strTitle
End Property
Property Get DBName() As String
  DBName = Nz(Properties.strDBName, Message)
End Property
Property Let SQL(Value As String)
  If UCase(Left(Value, 6)) <> "SELECT" Then
    MsgBox "Can only send a standard select query in this version.", vbCritical, strTitle
    Properties.blnSQLGiven = False
    Properties.strSQLQuery = ""
  Else
    Properties.blnSQLGiven = (Value <> "")
    Properties.strSQLQuery = Value
  End If
End Property
Property Get SQL() As String
  SQL = Nz(Properties.strSQLQuery, Message)
End Property
Property Let SaveAs(Name As String)
  'Attempt to create this file before setting the value
  Properties.blnSaveFileName = (Name <> "")
  Properties.strSaveFileName = Name
End Property
Property Get SaveAs() As String
  SaveAs = Nz(Properties.strSaveFileName, Message)
End Property
Public Function OpenFile() As String
  Dim Flags As Long
  Flags = adhOFN_PATHMUSTEXIST + adhOFN_FILEMUSTEXIST + adhOFN_LONGNAMES + adhOFN_EXPLORER
  OpenFile = adhCommonFileOpenSave(Flags, strCurrDir, "Excel Files (*.xls)" & vbNullChar & "*.xls", , , , "Open File", True)
  If OpenFile <> "" Then strCurrDir = Mid(OpenFile, 1, InStrRev(OpenFile, "\"))
End Function
Public Function OpenDatabase() As String
  Dim Flags As Long
  Flags = adhOFN_PATHMUSTEXIST + adhOFN_FILEMUSTEXIST + adhOFN_LONGNAMES + adhOFN_EXPLORER
  OpenDatabase = adhCommonFileOpenSave(Flags, strCurrDir, "Access Database (*.mdb)" & vbNullChar & "*.mdb", , , , "Open Database", True)
  If OpenDatabase <> "" Then strCurrDir = Mid(OpenDatabase, 1, InStrRev(OpenDatabase, "\"))
End Function
Public Function SaveFileAs() As String
  Dim Flags As Long
  Flags = adhOFN_PATHMUSTEXIST + adhOFN_FILEMUSTEXIST + adhOFN_LONGNAMES + adhOFN_EXPLORER + adhOFN_OVERWRITEPROMPT
  SaveFileAs = adhCommonFileOpenSave(Flags, strCurrDir, "Excel Files (*.xls)" & vbNullChar & "*.xls", 1, "xls", , "Save As..", False)
  If SaveFileAs <> "" Then strCurrDir = Mid(SaveFileAs, 1, InStrRev(SaveFileAs, "\"))
End Function
Public Function Export() As Boolean
  Dim intResult As Integer
  Dim Exiting As Boolean
  Dim strTempFile As String
  With Properties
    'check to see if the table and sql have been sent
    If (.blnSQLGiven) And (.blnTableGiven) Then
      intResult = MsgBox("You have supplied both a table name and an SQL query." & VBA.vbCrLf & _
        "Click yes to use the table reference, or no to use the SQL. Click Cancel to exit.", vbInformation & _
        vbYesNoCancel, strTitle)
      Select Case intResult
        Case vbYes:
          SQL = ""
          Export = DoTableExport
        Case vbNo:
          TableName = ""
          Export = DoSQLExport
        Case vbCancel
          Exit Function
      End Select
    ElseIf (.blnSQLGiven) Then
      Export = DoSQLExport
    ElseIf (.blnTableGiven) Then
      Export = DoTableExport
    Else
      MsgBox "Please supply a tablename or SQL query to start.", vbCritical, strTitle
      Exit Function
    End If
    If Export = False Then
      If FileOpened Then obXL.ActiveWorkbook.Close False
      MsgBox "The Export to an Excel File has been cancelled.", vbInformation, strTitle
    Else
      'the process here is to determine what finishing options have been chosen and then any
      'subsequent choices or values need to be checked.
      If .blnCloseWhenFinished Then 'user has chosen to close when finished or not changed default
        If .blnFileGiven And Not .blnSaveFileName Then 'the user is using an existing file, prompt
          If vbYes = MsgBox("Do you want to save your existing file under the same filename?", vbYesNo, strTitle) Then
            'user wants to save their file
            obXL.ActiveWorkbook.Save
          ElseIf vbYes = MsgBox("Save this file under a new filename?", vbYesNo, strTitle) Then
            'user is wanting a new file name loop until they supply a valid name
            Do While SaveAs = "" And Not Exiting
              strTempFile = SaveFileAs
              Exiting = (strTempFile = "")
              If Not Exiting Then SaveAs = strTempFile
            Loop
            If Exiting Then
              MsgBox "You have chosen to close the unsaved workbook, losing all changes.", vbCritical, strTitle & ": WARNING"
              Exit Function 'has cancelled the save dialog exit function
            End If
            obXL.ActiveWorkbook.SaveAs .strSaveFileName
          ElseIf vbYes = MsgBox("Keep this file open instead?", vbYesNo, strTitle) Then
            CloseWhenDone = False
          Else 'user has chosen to close the file losing all changes
            MsgBox "You have chosen to close the unsaved workbook, losing all changes.", vbCritical, strTitle & ": WARNING"
          End If
        ElseIf ((.blnFileGiven) Or Not (.blnFileGiven)) And .blnSaveFileName Then
          'the user has chosen to save the workbook as another file or this is a new file
          'perform and inform
          obXL.ActiveWorkbook.SaveAs .strSaveFileName
          MsgBox "You work book has been saved as:" & vbCrLf & vbCrLf & .strSaveFileName, vbInformation, strTitle
        ElseIf Not (.blnFileGiven) And Not (.blnSaveFileName) Then
          'this is a new file and the user has not supplied a filename, prompt for choices
          If vbYes = MsgBox("Do you want to save this workbook?", vbYesNo, strTitle) Then
            Do While SaveAs = "" And Not Exiting
              strTempFile = SaveFileAs
              Exiting = (strTempFile = "")
              If Not Exiting Then SaveAs = strTempFile
            Loop
            If Exiting Then
              MsgBox "You have chosen to close the unsaved workbook, losing all changes.", vbCritical, strTitle & ": WARNING"
              Exit Function 'has cancelled the save dialog exit function
            End If
            obXL.ActiveWorkbook.SaveAs .strSaveFileName
          ElseIf vbYes = MsgBox("Do you want to keep the file open then?", vbYesNo, strTitle) Then
            CloseWhenDone = False
          Else
            MsgBox "You have chosen to close the unsaved workbook, losing all changes.", vbCritical, strTitle & ": WARNING"
          End If
        End If
      Else
        MsgBox "The finalised workbook has been left open for you.", vbInformation, strTitle
        If Not .blnShowExcel Then ShowExcel = True
      End If
    End If
  End With
End Function
Private Function DoTableExport() As Boolean
  Dim lngRowNumber As Long
  Dim i As Integer, j As Integer
  With Properties
  If CheckOutput = False Then
    DoTableExport = False
    Exit Function
  Else
    If .blnDBGiven Then
      Set Db = DAO.OpenDatabase(.strDBName)
    Else
      Set Db = CurrentDb
    End If
    Set Rc = Db.OpenRecordset(.strTableName)
    DoTableExport = OutPutData
    Set Rc = Nothing
    If .blnDBGiven Then Db.Close
    Set Db = Nothing
  End If
  End With
End Function
Private Function DoSQLExport() As Boolean
  'a quick check on whether the user has supplied a cell address and a range address
  With Properties
    If CheckOutput = False Then
      DoSQLExport = False
      Exit Function
    Else
      'do not know whether the SQL sent be the user will work so attempt to create it in the database
      'that has been set, if this errors inform the user and exit function
      If .blnDBGiven Then
        Set Db = DAO.OpenDatabase(.strDBName)
      Else
        Set Db = CurrentDb
      End If
      'open the Select SQL in the recordset object
      On Error GoTo InvalidSQL
      Set Rc = Db.OpenRecordset(.strSQLQuery)
      On Error GoTo 0
      'if code reaches here then the SQL sent is ok to use
      DoSQLExport = OutPutData
      Set Rc = Nothing
      If .blnDBGiven Then Db.Close
      Set Db = Nothing
    End If
  End With
  Exit Function
  
InvalidSQL:
  MsgBox "The SQL you have sent is invalid, please try again.", vbCritical, strTitle
  Set Rc = Nothing
  If Properties.blnDBGiven Then Db.Close
  Set Db = Nothing
  Exit Function
End Function
Private Function CheckOutput() As Boolean
  Dim intResult As Integer
  Dim NewFileName As String
  Dim Exiting As Boolean
  Dim i As Integer
  With Properties
    'initial check to see if the filename has been set, otherwise create a new workbook
    
Checking:
    If (.blnFileGiven) Then
      'first check to see if a range and cell address has been given
      If (.blnCellGiven) And (.blnRangeGiven) Then
        'there is both a cell address and a range address ask use as to which they want to use
        intResult = MsgBox("You have supplied both an input range and cell reference." & vbCrLf & _
          "Press Yes to use the Cell reference, or No to use the Range reference.", _
          vbYesNoCancel, strTitle)
        Select Case intResult
          Case vbYes
            'user has chosen to use the cell reference, clear the range address
            RangeAddress = ""
          Case vbNo
            'user has chosen to use the range address, clear the cell reference
            CellAddress = ""
          Case vbCancel
            'user has clicked cancel, exit the function leaving the return call as false
            Exit Function
        End Select
      End If
      'now check to make sure that either a cell and sheet name or a range address are present
      If (.blnCellGiven) Then 'the celladdress has been set
        If (.blnSheetGiven) Then
          'we have a filename, sheetname and a cell address, open this workbook and check for sheet name
          obXL.Workbooks.Open .strFileName
          FileOpened = True
          On Error GoTo NoSheetName
          obXL.Sheets(.strSheetName).Select
          On Error GoTo 0
          'if code gets here then this is a valid sheetname continue on, the cell reference is
          'validated when entered
        Else
          'the user has set a filename and a cell reference but not a spreadsheet name, capture the names
          'and prompt the user as to which sheet they would like
          obXL.Workbooks.Open .strFileName
          FileOpened = True
          MsgBox "No Sheet Name Supplied, please choose a sheet to use.", vbInformation, strTitle
          SheetName = ChooseSheet
          If Not (.blnSheetGiven) Then Exit Function
        End If
      ElseIf (.blnSheetGiven) Then
        'user has supplied a sheetname and a filename but not a cell reference
        MsgBox "No Cell address supplied, please input a cell address.", vbInformation, strTitle
        CellAddress = NewCellReference
        If Not (.blnCellGiven) Then Exit Function
      ElseIf (.blnRangeGiven) Then 'the range has been set
        'attempt to find the range
        obXL.Workbooks.Open .strFileName
        FileOpened = True
        On Error GoTo NoRange
        obXL.Range(.strRangeAddress).Select
        On Error GoTo 0
        'if code returns to this point then the user has chosen their new options return to calling
        'function and check the output details
      Else
        'only the filename has been set, ask for a cell address and sheetname or a range
        If vbYes = MsgBox("You have selected a filename but nothing else." & vbCrLf & _
          "Do you want to continue with this filename?", vbYesNo, strTitle) Then
          'the user has confirmed that they want to use this filename so ask them for the cell address
          obXL.Workbooks.Open .strFileName
          FileOpened = True
          If vbYes = MsgBox("Do you want to set a Cell Address?", vbYesNo, strTitle) Then
            SheetName = ChooseSheet
            If Not (.blnSheetGiven) Then Exit Function
            CellAddress = NewCellReference
            If Not (.blnCellGiven) Then Exit Function
          ElseIf vbYes = MsgBox("Do you want to set a range object?", vbYes, strTitle) Then
            RangeAddress = ChooseRange
            If Not (.blnRangeGiven) Then Exit Function
          ElseIf vbYes = MsgBox("Create a new workbook?", vbYesNo, strTitle) Then
            obXL.ActiveWorkbook.Close False
            GoSub CreateNew
          Else
            'exit the function as the user has chosen nothing
            Exit Function
          End If
        ElseIf vbYes = MsgBox("Create a new workbook?", vbYesNo, strTitle) Then
          GoSub CreateNew
        Else
          'nothing selected so exit function
          Exit Function
        End If
      End If
    Else
      'the filename has not been set check to see if either the range or sheet and cell has been set
      If .blnCellGiven Or .blnRangeGiven Or .blnSheetGiven Then
        If vbYes = MsgBox("You have selected a worksheet object but not an existing worksheet." & _
          vbCrLf & "Do you want to include a filename now?", vbYesNo, strTitle) Then
          GoSub ChooseOpen
          GoSub Checking
        ElseIf vbYes = MsgBox("Do you want to create a new spreadsheet then?", vbYesNo, strTitle) Then
          GoSub CreateNew
        Else
          'exit function as the user does not know what they want to do
          Exit Function
        End If
      Else
        'the only other option remaining is to create a new workbook
        If vbYes = MsgBox("You have chosen to create a new workbook." & vbCrLf & _
          "Is this correct?", vbYesNo, strTitle) Then
          GoSub CreateNew
        Else
          'user has chosen nothing so exit function
          Exit Function
        End If
      End If
    End If
  CheckOutput = True
  Exit Function
  
NoSheetName:
  If vbYes = MsgBox("The Sheetname you have supplied does not exist in the selected workbook." & vbCrLf & _
    vbCrLf & "Do you wish to place extract on a new workbook.", vbInformation + vbYesNo, strTitle) Then
    obXL.Workbooks(.strShortFName).Close
    'close this workbook and create a new workbook, ask for sheetname and cell reference
    GoSub CreateNew
    Resume
  ElseIf vbYes = MsgBox("Add A New sheet to this workbook instead?", vbYesNo, strTitle) Then
    'set the name conditionally, if the user wants to change then change it in the next statement
    SheetName = MakeNewSheet
    If vbYes = MsgBox("Do you want to change '" & SheetName & "'?", vbYesNo, strTitle) Then
      SheetName = NewSheetName(SheetName)
      If Not (.blnSheetGiven) = False Then Exit Function
    End If
    Resume
  ElseIf vbYes = MsgBox("Choose a different Sheet name?", vbYesNo, strTitle) Then
    SheetName = ChooseSheet
    If Not (.blnSheetGiven) = False Then Exit Function
    Resume
  ElseIf vbYes = MsgBox("Change the filename instead?", vbYesNo, strTitle) Then
    .strFileName = ""
    GoSub ChooseOpen
    Resume
  Else
    'no other options remain so cancel the export
    Exit Function
  End If
  
NoRange:
  If vbYes = MsgBox("Invalid Range Name set." & vbCrLf & vbCrLf & "Do you want to set a cell reference instead?" _
    , vbYesNo, strTitle) Then
    RangeAddress = ""
    CellAddress = NewCellReference
    If Not (.blnCellGiven) Then Exit Function
    Resume
  ElseIf vbYes = MsgBox("Choose A different Range instead?", vbYesNo, strTitle) Then
    RangeAddress = ChooseRange
    If Not (.blnRangeGiven) Then Exit Function
    Resume
  ElseIf vbYes = MsgBox("Do you wish to place extract on a new workbook.", vbYesNo, strTitle) Then
    obXL.Workbooks(.strShortFName).Close
    'close this workbook and create a new workbook, ask for sheetname and cell reference
    RangeAddress = ""
    GoSub CreateNew
    Resume
  ElseIf vbYes = MsgBox("Change the filename instead?", vbYesNo, strTitle) Then
    'ask to change filename instead
    obXL.ActiveWorkbook.Close False
    GoSub ChooseOpen
    obXL.Workbooks.Open .strFileName
    Resume 'check again for this range
  Else
    'user cannot choose so exit the function completely
    Exit Function
  End If
  Exit Function
  
ChooseOpen:
  Do While .strFileName = "" And Not Exiting
    NewFileName = OpenFile
    Exiting = (NewFileName = "")
    Filename = NewFileName
  Loop
  If Exiting Then Exit Function 'chose not to include filename so kick out
  Return
  
CreateNew:
  obXL.Workbooks.Add
  FileOpened = True
  If vbYes = MsgBox("The default sheet name is 'Sheet1', do you want to use this sheet?", vbYesNo, strTitle) Then
    SheetName = "Sheet1"
  ElseIf vbYes = MsgBox("Rename the sheet from 'sheet1'?", vbYesNo, strTitle) Then
    SheetName = NewSheetName("Sheet1")
    If Not (.blnSheetGiven) Then Exit Function
  ElseIf vbYes = MsgBox("Add A new sheet to this workbook instead?", vbYesNo, strTitle) Then
    'set the name conditionally, if the user wants to change then change it in the next statement
    SheetName = MakeNewSheet
    If vbYes = MsgBox("Do you want to change '" & SheetName & "'?", vbYesNo, strTitle) Then
      SheetName = NewSheetName(SheetName)
      If Not (.blnSheetGiven) Then Exit Function
    End If
  Else 'the user has decided not to use any sheet on the workbook.
    obXL.ActiveWorkbook.Close False
    Exit Function
  End If
  Return
  
End With
End Function
Private Function NewCellReference() As String
  Dim NewCell As String
  Dim Exiting As Boolean
  Properties.blnCellGiven = False
  Do While NewCell = "" And Not Exiting
    'ask for new cell reference, supplying the original cell address as the default
    NewCell = InputBox("Enter New Cell Reference.", "New Cell Reference", CellAddress)
    Exiting = (NewCell = "")
  Loop
  If Exiting Then
    If vbYes = MsgBox("Deafult to 'A1' instead?", vbYesNo, strTitle) Then
      NewCell = "A1"
    Else
      Exit Function
    End If
  End If
  NewCellReference = NewCell
End Function
Private Function NewSheetName(pSheetName As String) As String
  Dim NewSheet As String
  Dim Exiting As Boolean
  Do While NewSheet = "" And Not Exiting
    NewSheet = InputBox("Enter New Sheet Name.", "New Sheet", SheetName)
    Exiting = (NewSheet = "")
  Loop
  If Exiting Then Exit Function
  Select Case LCase(NewSheet)
    Case "sheet1", "sheet2", "sheet3"
      'do nothing as this is a default sheet
    Case Else
      'user has chosen their own sheet name, so rename the sheet to match
      obXL.Worksheets(pSheetName).Name = NewSheet
  End Select
  NewSheetName = NewSheet
End Function
Private Function MakeNewSheet() As String
  obXL.Worksheets.Add , obXL.Worksheets(obXL.Worksheets.Count)
  MakeNewSheet = obXL.Worksheets(obXL.Worksheets.Count).Name
End Function
Private Function ChooseSheet() As String
  Dim i As Integer
  'scan through the existing sheets and question the user if they want to use it
  For i = 1 To obXL.Worksheets.Count
    If vbYes = MsgBox("Use " & obXL.Worksheets(i).Name & "?", vbYesNo, strTitle) Then Exit For
  Next i
  If i <= obXL.Worksheets.Count Then
    ChooseSheet = obXL.Worksheets(i).Name
  ElseIf vbYes = MsgBox("Make a new Sheet?", vbYesNo, strTitle) Then
    ChooseSheet = MakeNewSheet
  Else
    ChooseSheet = ""
  End If
End Function
Private Function ChooseRange() As String
  Dim i As Integer
  If obXL.Names.Count = 0 Then
    MsgBox "This workbook contains no range names.", vbCritical, strTitle
    Exit Function
  End If
  For i = 1 To obXL.Names.Count
    If vbYes = MsgBox("Use '" & obXL.Names(i).Name & "'?", vbYesNo, strTitle) Then Exit For
  Next i
  If i <= obXL.Names.Count Then
    ChooseRange = obXL.Names(i).Name
  Else
    MsgBox "No Range object selected", vbCritical, strTitle
  End If
End Function
Private Function OutPutData() As Boolean
  Dim lngRowNumber As Long
  Dim i As Integer, j As Integer
  With Properties
    If (.blnCellGiven) Then
      obXL.Sheets(.strSheetName).Select
      obXL.Range(.strCellAddress).Select
    ElseIf (.blnRangeGiven) Then
      obXL.Range(.strRangeAddress).Select
      obXL.ActiveCell.Offset(0, 0).Select
    End If
    lngRowNumber = obXL.ActiveCell.Row
    Do While Not (Rc.EOF)
      Rc.MoveNext
    Loop
    If Rc.RecordCount = 0 Then
      'no records to output
      MsgBox "The selected table has no records.", vbInformation, strTitle
      Exit Function
    ElseIf Rc.RecordCount > 65535 Then
      MsgBox "This version of clsExport does not currently support more than 65,536 rows of data." & _
        vbCrLf & "Please try a smaller table or query your data into manageable chunks.", vbCritical, strTitle
      Exit Function
    ElseIf lngRowNumber + Rc.RecordCount > 65535 Then
      MsgBox "You have set a cell or range address which when added to the data from the table" & vbCrLf & _
        "will make the data go off the end of the spreadsheet." & vbCrLf & vbCrLf & _
        "Please re-try by setting the cell reference to a smaller value.", vbInformation, strTitle
      Exit Function
    Else
      'all is okay to populate the spreadsheet with the figures.
      Rc.MoveFirst
      If (.blnIncludeFields) Then
        'the user wants the fields output as well so do this first
        For i = 0 To Rc.Fields.Count - 1
          obXL.ActiveCell.Offset(0, i).Value = Rc.Fields(i).Name
        Next i
        'offset down a row and populate the remainder of the spreadsheet
        obXL.ActiveCell.Offset(1, 0).Select
      End If
      For i = 0 To Rc.RecordCount - 1
        For j = 0 To Rc.Fields.Count - 1
          obXL.ActiveCell.Offset(i, j).Value = Rc(j).Value
        Next j
        Rc.MoveNext
      Next i
      OutPutData = True
    End If
  End With
End Function

'************************************************************************************************
'*                              COMMONDIALOG CODE FOLLOWS                                       *
'************************************************************************************************
Private Function adhCommonFileOpenSave(Optional ByRef Flags As Variant, Optional ByVal InitialDir As Variant, Optional ByVal Filter As Variant, _
 Optional ByVal FilterIndex As Variant, Optional ByVal DefaultExt As Variant, Optional ByVal Filename As Variant, Optional ByVal DialogTitle As Variant, _
 Optional ByVal OpenFile As Variant) As Variant

    ' This is the entry point you'll use to call the common file open/save dialog. The parameters are listed below, and all are optional.
    ' In:
    '    Flags: one or more of the adhOFN_* constants, OR'd together.
    '    InitialDir: the directory in which to first look
    '    Filter: a set of file filters, set up by calling AddFilterItem.  See examples.
    '    FilterIndex: 1-based integer indicating which filter set to use, by default (1 if unspecified)
    '    DefaultExt: Extension to use if the user doesn't enter one. Only useful on file saves.
    '    FileName: Default value for the file name text box.
    '    DialogTitle: Title for the dialog.
    '    OpenFile: Boolean(True=Open File/False=Save As)
    ' Out:
    '    Return Value: Either Null or the selected filename
    Dim ofn As tagOPENFILENAME, strFileName$, strFileTitle$, fResult As Boolean
    ' Give the dialog a caption title.
    If IsMissing(InitialDir) Then InitialDir = ""
    If IsMissing(Filter) Then Filter = ""
    If IsMissing(FilterIndex) Then FilterIndex = 1
    If IsMissing(Flags) Then Flags = 0&
    If IsMissing(DefaultExt) Then DefaultExt = ""
    If IsMissing(Filename) Then Filename = ""
    If IsMissing(DialogTitle) Then DialogTitle = ""
    If IsMissing(OpenFile) Then OpenFile = True
    ' Allocate string space for the returned strings.
    strFileName = VBA.Left(Filename & VBA.String(256, 0), 256)
    strFileTitle = VBA.String(256, 0)
    ' Set up the data structure before you call the function
    With ofn
        .lStructSize = Len(ofn)
        .hWndOwner = Application.hWndAccessApp
        .strFilter = Filter
        .NFilterIndex = FilterIndex
        .strFile = strFileName
        .nMaxFile = VBA.Len(strFileName)
        .strFileTitle = strFileTitle
        .nMaxFileTitle = VBA.Len(strFileTitle)
        .strTitle = DialogTitle
        .Flags = Flags
        .strDefExt = DefaultExt
        .strInitialDir = InitialDir
        ' Didn't think most people would want to deal with these options.
        .hInstance = 0
        .strCustomFilter = VBA.String(255, 0)
        .nMaxCustFilter = 255
        .lpfnHook = 0
    End With
    ' This will pass the desired data structure to the Windows API, which will in turn it uses to display the Open/Save As Dialog.
    If OpenFile Then
        fResult = adh_apiGetOpenFileName(ofn)
    Else
        fResult = adh_apiGetSaveFileName(ofn)
    End If
    ' The function call filled in the strFileTitle member of the structure. You'll have to write special code to retrieve that if you're interested.
    If fResult Then
        ' You might care to check the Flags member of the structure to get information about the chosen file. In this example, if you bothered to pass in a
        ' value for Flags, we'll fill it in with the outgoing Flags value.
        If Not IsMissing(Flags) Then Flags = ofn.Flags
        adhCommonFileOpenSave = adhTrimNull(ofn.strFile)
    Else
        adhCommonFileOpenSave = Empty
    End If
End Function
Private Function adhAddFilterItem(strFilter As String, strDescription As String, Optional varItem As Variant) As String
  ' Tack a new chunk onto the file filter. That is, take the old value, stick onto it the description, (like "Databases"), a null character, the skeleton
  ' (like "*.mdb;*.mda") and a final null character.
  ' In:
    '       strFilter: existing file filter
    '       strDescription: new filter description
    '       varItem: new filter
    ' Out:
    '       Return value: new file filter
  If IsMissing(varItem) Then varItem = "*.*"
  adhAddFilterItem = strFilter & strDescription & vbNullChar & varItem & vbNullChar
End Function
Private Function adhTrimNull(ByVal strItem As String) As String
  ' Trims the Null from a string returned by an API call
  ' In: strItem: string that contains null terminator
  ' Out: Return value: same string without null terminator
  Dim intPos As Integer
  intPos = VBA.InStr(strItem, vbNullChar)
  If intPos > 0 Then
    adhTrimNull = VBA.Left(strItem, intPos - 1)
  Else
    adhTrimNull = strItem
  End If
End Function

